home *** CD-ROM | disk | FTP | other *** search
/ Netscape Plug-Ins Developer's Kit / Netscape_Plug-Ins_Developers_Kit.iso / CGIPERL / MACPERL / MSRCE418.HQX / Perl Source ƒ / Perl / perl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-01-15  |  42.9 KB  |  1,736 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of the Perl Artistic License, 
  6.  *    as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 4.0.1.7  1992/06/08  14:50:39  lwall
  10.  * patch20: PERLLIB now supports multiple directories
  11.  * patch20: running taintperl explicitly now does checks even if $< == $>
  12.  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  13.  * patch20: perl -P now uses location of sed determined by Configure
  14.  * patch20: form feed for formats is now specifiable via $^L
  15.  * patch20: paragraph mode now skips extra newlines automatically
  16.  * patch20: eval "1 #comment" didn't work
  17.  * patch20: couldn't require . files
  18.  * patch20: semantic compilation errors didn't abort execution
  19.  * 
  20.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  21.  * patch19: default arg for shift was wrong after first subroutine definition
  22.  * patch19: op/regexp.t failed from missing arg to bcmp()
  23.  * 
  24.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  25.  * patch11: random cleanup
  26.  * patch11: $0 was being truncated at times
  27.  * patch11: cppstdin now installed outside of source directory
  28.  * patch11: -P didn't allow use of #elif or #undef
  29.  * patch11: prepared for ctype implementations that don't define isascii()
  30.  * patch11: added eval {}
  31.  * patch11: eval confused by string containing null
  32.  * 
  33.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  34.  * patch10: perl -v printed incorrect copyright notice
  35.  * 
  36.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  37.  * patch4: changed old $^P to $^X
  38.  * 
  39.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  40.  * patch4: new copyright notice
  41.  * patch4: added $^P variable to control calling of perldb routines
  42.  * patch4: added $^F variable to specify maximum system fd, default 2
  43.  * patch4: debugger lost track of lines in eval
  44.  * 
  45.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  46.  * patch1: fixed undefined environ problem
  47.  * 
  48.  * Revision 4.0  91/03/20  01:37:44  lwall
  49.  * 4.0 baseline.
  50.  * 
  51.  */
  52.  
  53. /*SUPPRESS 560*/
  54.  
  55. #ifdef macintosh
  56. #define RESOLVE_MAC_CONFLICTS
  57. #include <Dialogs.h>
  58. #include <Files.h>
  59.  
  60. char **init_env(char **);
  61.  
  62. #define MP_EXT 
  63. #define MP_INIT(x) = x
  64.  
  65. #include "MacPerl.h"
  66.  
  67. #undef INIT
  68.  
  69. #if !defined(powerc) && !defined(__powerc)
  70. #include <Resources.h>
  71.  
  72. #ifdef PERFORMANCE
  73. #include <Perf.h>
  74.  
  75. TP2PerfGlobals    gPerfGlobals;
  76.  
  77. void FinalizePerf()
  78. {
  79.     PerfDump(gPerfGlobals, "\pPerfPerl.Out", true, 80);
  80.     TermPerf(gPerfGlobals);
  81. }
  82.  
  83. #endif
  84. #endif
  85.  
  86. #else
  87. char * getenv();
  88. #endif
  89.  
  90. #include "EXTERN.h"
  91. #include "perl.h"
  92. #include "perly.h"
  93. #include "patchlevel.h"
  94.  
  95. #ifdef IAMSUID
  96. #ifndef DOSUID
  97. #define DOSUID
  98. #endif
  99. #endif
  100.  
  101. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  102. #ifdef DOSUID
  103. #undef DOSUID
  104. #endif
  105. #endif
  106.  
  107. static char* moreswitches();
  108. static void incpush();
  109. static char* cddir;
  110. static bool minus_c;
  111. static char patchlevel[6];
  112. static char *nrs = "\n";
  113. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  114. static int nrslen = 1;
  115.  
  116. #if defined(MAC_STANDALONE) || defined(powerc) || defined (__powerc)
  117. run_perl(argc,argv,env)
  118. #else
  119. main(argc,argv,env)
  120. #endif
  121. register int argc;
  122. register char **argv;
  123. register char **env;
  124. {
  125.     register STR *str;
  126.     register char *s;
  127.     char *scriptname;
  128.     bool dosearch = FALSE;
  129. #ifdef DOSUID
  130.     char *validarg = "";
  131. #endif
  132.     
  133. #ifdef macintosh
  134.     FSSpec    pref;
  135.  
  136.     InitToolbox();
  137.     
  138.     gStartClock = clock();
  139.  
  140. #if !defined(MAC_STANDALONE) && !defined(powerc) && !defined(__powerc)
  141. #ifdef PERFORMANCE
  142.     InitPerf(&gPerfGlobals, 10, 8, true, true, "\pCODE", 0, "\p", true, 0, 0x7fffff, 32);
  143.     PerfControl(gPerfGlobals, true);
  144.     atexit(FinalizePerf);
  145. #endif
  146.     
  147.     gAppFile     = CurResFile();
  148.     
  149.     if (Path2FSSpec(getenv("PrefsFolder"), &pref))
  150.         gPrefsFile = 0;
  151.     else if (FSpDown(&pref, "\pPerl Preferences"))
  152.         gPrefsFile = 0;
  153.     else {
  154.         gPrefsFile = HOpenResFile(pref.vRefNum, pref.parID, pref.name, fsRdPerm);
  155.     
  156.     if (gPrefsFile == -1)
  157.         gPrefsFile = 0;
  158.     }
  159. #endif
  160.     InitCursorCtl(NULL);
  161.  
  162.     env = init_env(env);
  163. #endif
  164.  
  165. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  166. #ifdef IAMSUID
  167. #undef IAMSUID
  168.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  169. setuid perl scripts securely.\n");
  170. #endif
  171. #endif
  172.  
  173.     origargv = argv;
  174.     origargc = argc;
  175.     origenviron = environ;
  176.     uid = (int)getuid();
  177.     euid = (int)geteuid();
  178.     gid = (int)getgid();
  179.     egid = (int)getegid();
  180.     minus_c = 0;
  181.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  182. #ifdef MSDOS
  183.     /*
  184.      * There is no way we can refer to them from Perl so close them to save
  185.      * space.  The other alternative would be to provide STDAUX and STDPRN
  186.      * filehandles.
  187.      */
  188.     (void)fclose(stdaux);
  189.     (void)fclose(stdprn);
  190. #endif
  191.     if (do_undump) {
  192.     origfilename = savestr(argv[0]);
  193.     do_undump = 0;
  194.     loop_ptr = -1;        /* start label stack again */
  195.     goto just_doit;
  196.     }
  197. #ifdef TAINT
  198. #ifndef DOSUID
  199.     if (uid == euid && gid == egid)
  200.     taintanyway = TRUE;        /* running taintperl explicitly */
  201. #endif
  202. #endif
  203. #ifdef macintosh
  204.     if (scriptname = index(rcsid,'#'))
  205.         (void)sprintf(scriptname, "%d\n", PATCHLEVEL);
  206. #else
  207.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  208. #endif
  209.     linestr = Str_new(65,80);
  210.     str_nset(linestr,"",0);
  211.     str = str_make("",0);        /* first used for -I flags */
  212.     curstash = defstash = hnew(0);
  213.     curstname = str_make("main",4);
  214.     stab_xhash(stabent("_main",TRUE)) = defstash;
  215.     defstash->tbl_name = "main";
  216.     incstab = hadd(aadd(stabent("INC",TRUE)));
  217.     incstab->str_pok |= SP_MULTI;
  218.     for (argc--,argv++; argc > 0; argc--,argv++) {
  219.     if (argv[0][0] != '-' || !argv[0][1])
  220.         break;
  221. #ifdef DOSUID
  222.     if (*validarg)
  223.     validarg = " PHOOEY ";
  224.     else
  225.     validarg = argv[0];
  226. #endif
  227.     s = argv[0]+1;
  228.       reswitch:
  229.     switch (*s) {
  230.     case '0':
  231.     case 'a':
  232.     case 'c':
  233.     case 'd':
  234.     case 'D':
  235.     case 'i':
  236.     case 'l':
  237.     case 'n':
  238.     case 'p':
  239.     case 'u':
  240.     case 'U':
  241.     case 'v':
  242.     case 'w':
  243.         if (s = moreswitches(s))
  244.         goto reswitch;
  245.         break;
  246.  
  247.     case 'e':
  248. #ifdef TAINT
  249.         if (euid != uid || egid != gid)
  250.         fatal("No -e allowed in setuid scripts");
  251. #endif
  252.         if (!e_fp) {
  253.             e_tmpname = savestr(TMPPATH);
  254.         (void)mktemp(e_tmpname);
  255.         if (!*e_tmpname)
  256.             fatal("Can't mktemp()");
  257.         e_fp = fopen(e_tmpname,"w");
  258.         if (!e_fp)
  259.             fatal("Cannot open temporary file");
  260.         }
  261.         if (argv[1]) {
  262.         fputs(argv[1],e_fp);
  263.         argc--,argv++;
  264.         }
  265.         (void)putc('\n', e_fp);
  266.         break;
  267.     case 'I':
  268. #ifdef TAINT
  269.         if (euid != uid || egid != gid)
  270.         fatal("No -I allowed in setuid scripts");
  271. #endif
  272.         str_cat(str,"-");
  273.         str_cat(str,s);
  274.         str_cat(str," ");
  275.         if (*++s) {
  276.         (void)apush(stab_array(incstab),str_make(s,0));
  277.         }
  278.         else if (argv[1]) {
  279.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  280.         str_cat(str,argv[1]);
  281.         argc--,argv++;
  282.         str_cat(str," ");
  283.         }
  284.         break;
  285.     case 'P':
  286. #ifdef TAINT
  287.         if (euid != uid || egid != gid)
  288.         fatal("No -P allowed in setuid scripts");
  289. #endif
  290.         preprocess = TRUE;
  291.         s++;
  292.         goto reswitch;
  293.     case 's':
  294. #ifdef TAINT
  295.         if (euid != uid || egid != gid)
  296.         fatal("No -s allowed in setuid scripts");
  297. #endif
  298.         doswitches = TRUE;
  299.         s++;
  300.         goto reswitch;
  301.     case 'S':
  302. #ifdef TAINT
  303.         if (euid != uid || egid != gid)
  304.         fatal("No -S allowed in setuid scripts");
  305. #endif
  306.         dosearch = TRUE;
  307.         s++;
  308.         goto reswitch;
  309.     case 'x':
  310.         doextract = TRUE;
  311.         s++;
  312.         if (*s)
  313.         cddir = savestr(s);
  314.         break;
  315.     case '-':
  316.         argc--,argv++;
  317.         goto switch_end;
  318.     case 0:
  319.         break;
  320.     default:
  321.         fatal("Unrecognized switch: -%s",s);
  322.     }
  323.     }
  324.   switch_end:
  325.     scriptname = argv[0];
  326.     if (e_fp) {
  327.     if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
  328.         fatal("Can't write to temp file for -e: %s", strerror(errno));
  329.     argc++,argv--;
  330.     scriptname = e_tmpname;
  331.     }
  332.  
  333. #ifdef DOSISH
  334. #define PERLLIB_SEP ';'
  335. #else
  336. #ifdef macintosh
  337. #define PERLLIB_SEP ','
  338. #else
  339. #define PERLLIB_SEP ':'
  340. #endif
  341. #endif
  342. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  343. #ifdef MACPERL_STANDALONE
  344.     (void)apush(stab_array(incstab),str_make("Dev:Pseudo:",11));
  345. #endif
  346.     incpush(getenv("PERLLIB"));
  347. #endif /* TAINT */
  348.  
  349. #ifdef macintosh
  350. #ifdef PRIVLIB
  351.     incpush(PRIVLIB);
  352. #endif
  353.     (void)apush(stab_array(incstab),str_make(":",1));
  354. #else
  355. #ifndef PRIVLIB
  356. #define PRIVLIB "/usr/local/lib/perl"
  357. #endif
  358.     incpush(PRIVLIB);
  359.     (void)apush(stab_array(incstab),str_make(".",1));
  360. #endif
  361.  
  362.     str_set(&str_no,No);
  363.     str_set(&str_yes,Yes);
  364.  
  365.     /* open script */
  366.  
  367.     if (scriptname == Nullch)
  368. #ifdef MSDOS
  369.     {
  370.     if ( isatty(fileno(stdin)) )
  371.       moreswitches("v");
  372.     scriptname = "-";
  373.     }
  374. #else
  375. #ifdef macintosh
  376.     scriptname = "Dev:Stdin";
  377. #else
  378.     scriptname = "-";
  379. #endif
  380. #endif
  381. #ifdef macintosh
  382.     if (dosearch && !index(scriptname, ':') && (s = getenv("Commands"))) {
  383. #else
  384.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  385. #endif
  386.     char *xfound = Nullch, *xfailed = Nullch;
  387.     int len;
  388.  
  389.     bufend = s + strlen(s);
  390.     while (*s) {
  391. #ifndef DOSISH
  392. #ifndef macintosh
  393.         s = cpytill(tokenbuf,s,bufend,':',&len);
  394. #else
  395.         for (len = 0; *s && *s != ','; tokenbuf[len++] = *s++);
  396.         tokenbuf[len] = '\0';
  397. #endif
  398. #else
  399. #ifdef atarist
  400.         for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
  401.         tokenbuf[len] = '\0';
  402. #else
  403.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  404.         tokenbuf[len] = '\0';
  405. #endif
  406. #endif
  407.         if (*s)
  408.         s++;
  409. #ifndef DOSISH
  410. #ifdef macintosh
  411.         if (len && tokenbuf[len-1] != ':')
  412.         (void)strcat(tokenbuf+len,":");
  413. #else
  414.         if (len && tokenbuf[len-1] != '/')
  415.         (void)strcat(tokenbuf+len,"/");
  416. #endif
  417. #else
  418. #ifdef atarist
  419.         if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
  420.         (void)strcat(tokenbuf+len,"/");
  421. #else
  422.         if (len && tokenbuf[len-1] != '\\')
  423.         (void)strcat(tokenbuf+len,"\\");
  424. #endif
  425. #endif
  426.         (void)strcat(tokenbuf+len,scriptname);
  427. #ifdef DEBUGGING
  428. #ifdef macintosh
  429.         if (debug & 1)
  430.         fprintf(perldbg,"Looking for %s\n",tokenbuf);
  431. #else
  432.         if (debug & 1)
  433.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  434. #endif
  435. #endif
  436.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  437.         continue;
  438.         if (S_ISREG(statbuf.st_mode)
  439.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  440.         xfound = tokenbuf;              /* bingo! */
  441.         break;
  442.         }
  443.         if (!xfailed)
  444.         xfailed = savestr(tokenbuf);
  445.     }
  446.     if (!xfound)
  447.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  448.     if (xfailed)
  449.         Safefree(xfailed);
  450.     scriptname = savestr(xfound);
  451.     }
  452.  
  453.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  454.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  455.  
  456.     origfilename = savestr(scriptname);
  457.     curcmd->c_filestab = fstab(origfilename);
  458.     if (strEQ(origfilename,"-"))
  459.     argv[0] = "";
  460.     if (preprocess) {
  461. #ifndef macintosh
  462.     char *cpp = CPPSTDIN;
  463.  
  464.     if (strEQ(cpp,"cppstdin"))
  465.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  466.     else
  467.         sprintf(tokenbuf, "%s", cpp);
  468. #endif
  469. #ifdef PRIVLIB
  470.     str_cat(str,"-I");
  471.     str_cat(str,PRIVLIB);
  472. #endif
  473. #ifdef macintosh
  474.     (void)sprintf(buf, 
  475. "StreamEdit -e '/Ñ[┬#]/"
  476.                 "||/ìÑ#[ ╢t]*include[ ╢t]/"
  477.         "||/ìÑ#[ ╢t]*define[ ╢t]/"
  478.         "||/ìÑ#[ ╢t]*if[ ╢t]/"
  479.         "||/ìÑ#[ ╢t]*ifdef[ ╢t]/"
  480.         "||/ìÑ#[ ╢t]*ifndef[ ╢t]/"
  481.         "||/ìÑ#[ ╢t]*else/"
  482.         "||/ìÑ#[ ╢t]*elif/"
  483.         "||/ìÑ#[ ╢t]*undef/"
  484.         "||/ìÑ#[ ╢t]*endif/ Next' "
  485.                "-e '/ìÑ[ ╢t]*#┼/ Delete' "
  486. " %s | C -e %s",
  487.       scriptname, str_get(str));
  488. #else
  489. #ifdef MSDOS
  490.     (void)sprintf(buf, "\
  491. sed %s -e \"/^[^#]/b\" \
  492.  -e \"/^#[     ]*include[     ]/b\" \
  493.  -e \"/^#[     ]*define[     ]/b\" \
  494.  -e \"/^#[     ]*if[     ]/b\" \
  495.  -e \"/^#[     ]*ifdef[     ]/b\" \
  496.  -e \"/^#[     ]*ifndef[     ]/b\" \
  497.  -e \"/^#[     ]*else/b\" \
  498.  -e \"/^#[     ]*elif[     ]/b\" \
  499.  -e \"/^#[     ]*undef[     ]/b\" \
  500.  -e \"/^#[     ]*endif/b\" \
  501.  -e \"s/^#.*//\" \
  502.  %s | %s -C %s %s",
  503.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  504. #else
  505.     (void)sprintf(buf, "\
  506. %s %s -e '/^[^#]/b' \
  507.  -e '/^#[     ]*include[     ]/b' \
  508.  -e '/^#[     ]*define[     ]/b' \
  509.  -e '/^#[     ]*if[     ]/b' \
  510.  -e '/^#[     ]*ifdef[     ]/b' \
  511.  -e '/^#[     ]*ifndef[     ]/b' \
  512.  -e '/^#[     ]*else/b' \
  513.  -e '/^#[     ]*elif[     ]/b' \
  514.  -e '/^#[     ]*undef[     ]/b' \
  515.  -e '/^#[     ]*endif/b' \
  516.  -e 's/^[     ]*#.*//' \
  517.  %s | %s -C %s %s",
  518. #ifdef LOC_SED
  519.       LOC_SED,
  520. #else
  521.       "sed",
  522. #endif
  523.       (doextract ? "-e '1,/^#/d\n'" : ""),
  524. #endif
  525.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  526. #endif
  527. #ifdef DEBUGGING
  528. #ifdef macintosh
  529.     if (debug & 64) {
  530.         fputs(buf,perldbg);
  531.         fputs("\n",perldbg);
  532.     }
  533. #else
  534.     if (debug & 64) {
  535.         fputs(buf,stderr);
  536.         fputs("\n",stderr);
  537.     }
  538. #endif
  539. #endif
  540.     doextract = FALSE;
  541. #ifdef IAMSUID                /* actually, this is caught earlier */
  542.     if (euid != uid && !euid) {    /* if running suidperl */
  543. #ifdef HAS_SETEUID
  544.         (void)seteuid(uid);        /* musn't stay setuid root */
  545. #else
  546. #ifdef HAS_SETREUID
  547.         (void)setreuid(-1, uid);
  548. #else
  549.         setuid(uid);
  550. #endif
  551. #endif
  552.         if (geteuid() != uid)
  553.         fatal("Can't do seteuid!\n");
  554.     }
  555. #endif /* IAMSUID */
  556.     rsfp = mypopen(buf,"r");
  557.     }
  558.     else if (!*scriptname) {
  559. #ifdef TAINT
  560.     if (euid != uid || egid != gid)
  561.         fatal("Can't take set-id script from stdin");
  562. #endif
  563.     rsfp = stdin;
  564.     }
  565.     else
  566.     rsfp = fopen(scriptname,"r");
  567.     if ((FILE*)rsfp == Nullfp) {
  568. #ifdef DOSUID
  569. #ifndef IAMSUID        /* in case script is not readable before setuid */
  570.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  571.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  572.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  573.         execv(buf, origargv);    /* try again */
  574.         fatal("Can't do setuid\n");
  575.     }
  576. #endif
  577. #endif
  578.     fatal("Can't open perl script \"%s\": %s\n",
  579.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  580.     }
  581.     str_free(str);        /* free -I directories */
  582.     str = Nullstr;
  583.  
  584.     /* do we need to emulate setuid on scripts? */
  585.  
  586.     /* This code is for those BSD systems that have setuid #! scripts disabled
  587.      * in the kernel because of a security problem.  Merely defining DOSUID
  588.      * in perl will not fix that problem, but if you have disabled setuid
  589.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  590.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  591.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  592.      * discovers that it has opened a setuid script, it calls suidperl with
  593.      * the same argv that it had.  If suidperl finds that the script it has
  594.      * just opened is NOT setuid root, it sets the effective uid back to the
  595.      * uid.  We don't just make perl setuid root because that loses the
  596.      * effective uid we had before invoking perl, if it was different from the
  597.      * uid.
  598.      *
  599.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  600.      * be defined in suidperl only.  suidperl must be setuid root.  The
  601.      * Configure script will set this up for you if you want it.
  602.      *
  603.      * There is also the possibility of have a script which is running
  604.      * set-id due to a C wrapper.  We want to do the TAINT checks
  605.      * on these set-id scripts, but don't want to have the overhead of
  606.      * them in normal perl, and can't use suidperl because it will lose
  607.      * the effective uid info, so we have an additional non-setuid root
  608.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  609.      */
  610.  
  611. #ifdef DOSUID
  612.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  613.     fatal("Can't stat script \"%s\"",origfilename);
  614.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  615.     int len;
  616.  
  617. #ifdef IAMSUID
  618. #ifndef HAS_SETREUID
  619.     /* On this access check to make sure the directories are readable,
  620.      * there is actually a small window that the user could use to make
  621.      * filename point to an accessible directory.  So there is a faint
  622.      * chance that someone could execute a setuid script down in a
  623.      * non-accessible directory.  I don't know what to do about that.
  624.      * But I don't think it's too important.  The manual lies when
  625.      * it says access() is useful in setuid programs.
  626.      */
  627.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  628.         fatal("Permission denied");
  629. #else
  630.     /* If we can swap euid and uid, then we can determine access rights
  631.      * with a simple stat of the file, and then compare device and
  632.      * inode to make sure we did stat() on the same file we opened.
  633.      * Then we just have to make sure he or she can execute it.
  634.      */
  635.     {
  636.         struct stat tmpstatbuf;
  637.  
  638.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  639.         fatal("Can't swap uid and euid");    /* really paranoid */
  640.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  641.         fatal("Permission denied");    /* testing full pathname here */
  642.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  643.         tmpstatbuf.st_ino != statbuf.st_ino) {
  644.         (void)fclose(rsfp);
  645.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  646.             fprintf(rsfp,
  647. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  648. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  649.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  650.             statbuf.st_dev, statbuf.st_ino,
  651.             stab_val(curcmd->c_filestab)->str_ptr,
  652.             statbuf.st_uid, statbuf.st_gid);
  653.             (void)mypclose(rsfp);
  654.         }
  655.         fatal("Permission denied\n");
  656.         }
  657.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  658.         fatal("Can't reswap uid and euid");
  659.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  660.         fatal("Permission denied\n");
  661.     }
  662. #endif /* HAS_SETREUID */
  663. #endif /* IAMSUID */
  664.  
  665.     if (!S_ISREG(statbuf.st_mode))
  666.         fatal("Permission denied");
  667.     if (statbuf.st_mode & S_IWOTH)
  668.         fatal("Setuid/gid script is writable by world");
  669.     doswitches = FALSE;        /* -s is insecure in suid */
  670.     curcmd->c_line++;
  671.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  672.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  673.         fatal("No #! line");
  674.     s = tokenbuf+2;
  675.     if (*s == ' ') s++;
  676.     while (!isSPACE(*s)) s++;
  677.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  678.         fatal("Not a perl script");
  679.     while (*s == ' ' || *s == '\t') s++;
  680.     /*
  681.      * #! arg must be what we saw above.  They can invoke it by
  682.      * mentioning suidperl explicitly, but they may not add any strange
  683.      * arguments beyond what #! says if they do invoke suidperl that way.
  684.      */
  685.     len = strlen(validarg);
  686.     if (strEQ(validarg," PHOOEY ") ||
  687.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  688.         fatal("Args must match #! line");
  689.  
  690. #ifndef IAMSUID
  691.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  692.         euid == statbuf.st_uid)
  693.         if (!do_undump)
  694.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  695. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  696. #endif /* IAMSUID */
  697.  
  698.     if (euid) {    /* oops, we're not the setuid root perl */
  699.         (void)fclose(rsfp);
  700. #ifndef IAMSUID
  701.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  702.         execv(buf, origargv);    /* try again */
  703. #endif
  704.         fatal("Can't do setuid\n");
  705.     }
  706.  
  707.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
  708. #ifdef HAS_SETEGID
  709.         (void)setegid(statbuf.st_gid);
  710. #else
  711. #ifdef HAS_SETREGID
  712.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  713. #else
  714.         setgid(statbuf.st_gid);
  715. #endif
  716. #endif
  717.         if (getegid() != statbuf.st_gid)
  718.         fatal("Can't do setegid!\n");
  719.     }
  720.     if (statbuf.st_mode & S_ISUID) {
  721.         if (statbuf.st_uid != euid)
  722. #ifdef HAS_SETEUID
  723.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  724. #else
  725. #ifdef HAS_SETREUID
  726.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  727. #else
  728.         setuid(statbuf.st_uid);
  729. #endif
  730. #endif
  731.         if (geteuid() != statbuf.st_uid)
  732.         fatal("Can't do seteuid!\n");
  733.     }
  734.     else if (uid) {            /* oops, mustn't run as root */
  735. #ifdef HAS_SETEUID
  736.         (void)seteuid((UIDTYPE)uid);
  737. #else
  738. #ifdef HAS_SETREUID
  739.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  740. #else
  741.         setuid((UIDTYPE)uid);
  742. #endif
  743. #endif
  744.         if (geteuid() != uid)
  745.         fatal("Can't do seteuid!\n");
  746.     }
  747.     uid = (int)getuid();
  748.     euid = (int)geteuid();
  749.     gid = (int)getgid();
  750.     egid = (int)getegid();
  751.     if (!cando(S_IXUSR,TRUE,&statbuf))
  752.         fatal("Permission denied\n");    /* they can't do this */
  753.     }
  754. #ifdef IAMSUID
  755.     else if (preprocess)
  756.     fatal("-P not allowed for setuid/setgid script\n");
  757.     else
  758.     fatal("Script is not setuid/setgid in suidperl\n");
  759. #else
  760. #ifndef TAINT        /* we aren't taintperl or suidperl */
  761.     /* script has a wrapper--can't run suidperl or we lose euid */
  762.     else if (euid != uid || egid != gid) {
  763.     (void)fclose(rsfp);
  764.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  765.     execv(buf, origargv);    /* try again */
  766.     fatal("Can't run setuid script with taint checks");
  767.     }
  768. #endif /* TAINT */
  769. #endif /* IAMSUID */
  770. #else /* !DOSUID */
  771. #ifndef TAINT        /* we aren't taintperl or suidperl */
  772.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  773. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  774.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  775.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  776.         ||
  777.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  778.        )
  779.         if (!do_undump)
  780.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  781. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  782. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  783.     /* not set-id, must be wrapped */
  784.     (void)fclose(rsfp);
  785.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  786.     execv(buf, origargv);    /* try again */
  787.     fatal("Can't run setuid script with taint checks");
  788.     }
  789. #endif /* TAINT */
  790. #endif /* DOSUID */
  791.  
  792. #if !defined(IAMSUID) && !defined(TAINT)
  793.  
  794.     /* skip forward in input to the real script? */
  795.  
  796. #ifdef macintosh
  797.     /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */
  798.     
  799.     while (doextract || gAlwaysExtract) {
  800.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch) {
  801.         if (!gAlwaysExtract)
  802.             fatal("No Perl script found in input\n");
  803.         
  804.         if (doextract) {            /* require explicit override ? */
  805.             DialogPtr    dlg;
  806.         char         file[256];
  807.         
  808.         strcpy(file+1, MPWFileName(origfilename));
  809.         file[0] = strlen(file+1);
  810.         ParamText((StringPtr) file, "\p", "\p", "\p");
  811.         
  812.         if (Alert(270, (ModalFilterUPP) nil) == 2)
  813.             fatal("User aborted script\n");
  814.         else
  815.             doextract = FALSE;
  816.         }            
  817.         
  818.         /* Pater peccavi, file does not have #! */
  819.         rewind(rsfp);
  820.         curcmd->c_line = 0;
  821.         extract_offset = 0;
  822.         
  823.         break;
  824.     }
  825.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  826.         ungetc('\n',rsfp);        /* to keep line count right */
  827.         doextract = FALSE;
  828.         if (s = instr(s,"perl -")) {
  829.         s += 6;
  830. /* A truly horrible hack, but anybody who specifies -d in the #! line deserves
  831.    this
  832. */
  833.         for (;s; s = moreswitches(s)) 
  834.             if (*s == 'd' && !perldb)
  835.             (void)hadd(aadd(curcmd->c_filestab));
  836.         }
  837.         break;
  838.     }
  839.     extract_offset++;
  840.     } 
  841. #else
  842.     while (doextract) {
  843.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  844.         fatal("No Perl script found in input\n");
  845.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  846.         ungetc('\n',rsfp);        /* to keep line count right */
  847.         doextract = FALSE;
  848.         if (s = instr(s,"perl -")) {
  849.         s += 6;
  850.         /*SUPPRESS 530*/
  851.         while (s = moreswitches(s)) ;
  852.         }
  853.         if (cddir && chdir(cddir) < 0)
  854.         fatal("Can't chdir to %s",cddir);
  855.     }
  856.     }
  857. #endif
  858. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  859.  
  860.     defstab = stabent("_",TRUE);
  861.  
  862.     subname = str_make("main",4);
  863.     if (perldb) {
  864.     debstash = hnew(0);
  865.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  866.     curstash = debstash;
  867.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  868.     tmpstab->str_pok |= SP_MULTI;
  869.     dbargs->ary_flags = 0;
  870.     DBstab = stabent("DB",TRUE);
  871.     DBstab->str_pok |= SP_MULTI;
  872.     DBline = stabent("dbline",TRUE);
  873.     DBline->str_pok |= SP_MULTI;
  874.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  875.     tmpstab->str_pok |= SP_MULTI;
  876.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  877.     tmpstab->str_pok |= SP_MULTI;
  878.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  879.     tmpstab->str_pok |= SP_MULTI;
  880.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  881.     tmpstab->str_pok |= SP_MULTI;
  882.     curstash = defstash;
  883.     }
  884.  
  885.     /* init tokener */
  886.  
  887.     bufend = bufptr = str_get(linestr);
  888.  
  889.     savestack = anew(Nullstab);        /* for saving non-local values */
  890.     stack = anew(Nullstab);        /* for saving non-local values */
  891.     stack->ary_flags = 0;        /* not a real array */
  892.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  893.     afill(savestack,63); afill(savestack,-1);
  894.  
  895.     /* now parse the script */
  896.  
  897.     error_count = 0;
  898. #ifdef macintosh
  899.     if (gSyntaxError = (yyparse() || error_count)) {
  900.     if (minus_c)
  901.         fatal("%s had compilation errors.\n", MPWFileName(origfilename));
  902.     else 
  903.         fatal("Execution of %s aborted due to compilation errors.\n",
  904.         MPWFileName(origfilename));
  905.     }
  906. #else
  907.     if (yyparse() || error_count) {
  908.     if (minus_c)
  909.         fatal("%s had compilation errors.\n", origfilename);
  910.     else
  911.         fatal("Execution of %s aborted due to compilation errors.\n",
  912.         origfilename);
  913.     }
  914. #endif
  915.  
  916.     New(50,loop_stack,128,struct loop);
  917. #ifdef DEBUGGING
  918.     if (debug) {
  919.     New(51,debname,128,char);
  920.     New(52,debdelim,128,char);
  921. #ifdef macintosh
  922.     if (!gDebugLogName || !(perldbg = fopen(gDebugLogName, "w")))
  923.     perldbg = stderr;
  924. #endif
  925.     }
  926. #endif
  927.     curstash = defstash;
  928.  
  929.     preprocess = FALSE;
  930.     if (e_fp) {
  931.     e_fp = Nullfp;
  932.     (void)UNLINK(e_tmpname);
  933.     }
  934.  
  935.     /* initialize everything that won't change if we undump */
  936.  
  937.     if (sigstab = stabent("SIG",allstabs)) {
  938.     sigstab->str_pok |= SP_MULTI;
  939.     (void)hadd(sigstab);
  940.     }
  941.  
  942.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  943.     userinit();        /* in case linked C routines want magical variables */
  944.     macperlinit();
  945.  
  946.     amperstab = stabent("&",allstabs);
  947.     leftstab = stabent("`",allstabs);
  948.     rightstab = stabent("'",allstabs);
  949.     sawampersand = (amperstab || leftstab || rightstab);
  950.     if (tmpstab = stabent(":",allstabs))
  951.     str_set(stab_val(tmpstab),chopset);
  952.     if (tmpstab = stabent("\024",allstabs))
  953.     time(&basetime);
  954.  
  955.     /* these aren't necessarily magical */
  956.     if (tmpstab = stabent("\014",allstabs)) {
  957.     str_set(stab_val(tmpstab),"\f");
  958.     formfeed = stab_val(tmpstab);
  959.     }
  960.     if (tmpstab = stabent(";",allstabs))
  961.     str_set(STAB_STR(tmpstab),"\034");
  962.     if (tmpstab = stabent("]",allstabs)) {
  963.     str = STAB_STR(tmpstab);
  964.     str_set(str,rcsid);
  965.     str->str_u.str_nval = atof(patchlevel);
  966.     str->str_nok = 1;
  967.     }
  968.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  969.  
  970.     stdinstab = stabent("STDIN",TRUE);
  971.     stdinstab->str_pok |= SP_MULTI;
  972.     if (!stab_io(stdinstab))
  973.     stab_io(stdinstab) = stio_new();
  974.     stab_io(stdinstab)->ifp = stdin;
  975.     tmpstab = stabent("stdin",TRUE);
  976.     stab_io(tmpstab) = stab_io(stdinstab);
  977.     tmpstab->str_pok |= SP_MULTI;
  978.  
  979.     tmpstab = stabent("STDOUT",TRUE);
  980.     tmpstab->str_pok |= SP_MULTI;
  981.     if (!stab_io(tmpstab))
  982.     stab_io(tmpstab) = stio_new();
  983.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  984.     defoutstab = tmpstab;
  985.     tmpstab = stabent("stdout",TRUE);
  986.     stab_io(tmpstab) = stab_io(defoutstab);
  987.     tmpstab->str_pok |= SP_MULTI;
  988.  
  989.     curoutstab = stabent("STDERR",TRUE);
  990.     curoutstab->str_pok |= SP_MULTI;
  991.     if (!stab_io(curoutstab))
  992.     stab_io(curoutstab) = stio_new();
  993.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  994.     tmpstab = stabent("stderr",TRUE);
  995.     stab_io(tmpstab) = stab_io(curoutstab);
  996.     tmpstab->str_pok |= SP_MULTI;
  997.     curoutstab = defoutstab;        /* switch back to STDOUT */
  998.  
  999.     statname = Str_new(66,0);        /* last filename we did stat on */
  1000.  
  1001.     /* now that script is parsed, we can modify record separator */
  1002.  
  1003.     rs = nrs;
  1004.     rslen = nrslen;
  1005.     rschar = nrschar;
  1006.     rspara = (nrslen == 2);
  1007.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  1008.  
  1009.     if (do_undump)
  1010.     my_unexec();
  1011.  
  1012.   just_doit:        /* come here if running an undumped a.out */
  1013.     argc--,argv++;    /* skip name of script */
  1014.     if (doswitches) {
  1015.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  1016.         if (argv[0][1] == '-') {
  1017.         argc--,argv++;
  1018.         break;
  1019.         }
  1020.         if (s = index(argv[0], '=')) {
  1021.         *s++ = '\0';
  1022.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  1023.         }
  1024.         else
  1025.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  1026.     }
  1027.     }
  1028. #ifdef TAINT
  1029.     tainted = 1;
  1030. #endif
  1031.     if (tmpstab = stabent("0",allstabs)) {
  1032. #ifdef macintosh
  1033.     str_set(stab_val(tmpstab), MPWFileName(origfilename));
  1034. #else
  1035.     str_set(stab_val(tmpstab),origfilename);
  1036. #endif
  1037.     magicname("0", Nullch, 0);
  1038.     }
  1039.     if (tmpstab = stabent("\030",allstabs))
  1040.     str_set(stab_val(tmpstab),origargv[0]);
  1041.     if (argvstab = stabent("ARGV",allstabs)) {
  1042.     argvstab->str_pok |= SP_MULTI;
  1043.     (void)aadd(argvstab);
  1044.     aclear(stab_array(argvstab));
  1045.     for (; argc > 0; argc--,argv++) {
  1046.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  1047.     }
  1048.     }
  1049. #ifdef TAINT
  1050.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  1051. #endif
  1052.     if (envstab = stabent("ENV",allstabs)) {
  1053.     envstab->str_pok |= SP_MULTI;
  1054.     (void)hadd(envstab);
  1055.     hclear(stab_hash(envstab), FALSE);
  1056.     if (env != environ)
  1057.         environ[0] = Nullch;
  1058.     for (; *env; env++) {
  1059.         if (!(s = index(*env,'=')))
  1060.         continue;
  1061.         *s++ = '\0';
  1062.         str = str_make(s--,0);
  1063.         str_magic(str, envstab, 'E', *env, s - *env);
  1064.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  1065.         *s = '=';
  1066.     }
  1067.     }
  1068. #ifdef TAINT
  1069.     tainted = 0;
  1070. #endif
  1071.     if (tmpstab = stabent("$",allstabs))
  1072.     str_numset(STAB_STR(tmpstab),(double)getpid());
  1073.  
  1074.     if (dowarn) {
  1075.     stab_check('A','Z');
  1076.     stab_check('a','z');
  1077.     }
  1078.  
  1079.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  1080.     loop_ptr = -1;        /* start label stack again */
  1081.  
  1082. #ifdef DEBUGGING
  1083.     if (debug & 1024)
  1084.     dump_all();
  1085. #ifdef macintosh
  1086.     if (debug)
  1087.     fprintf(perldbg,"\nEXECUTING...\n\n");
  1088. #else
  1089.     if (debug)
  1090.     fprintf(stderr,"\nEXECUTING...\n\n");
  1091. #endif
  1092. #endif
  1093.  
  1094.     if (minus_c) {
  1095. #ifdef macintosh
  1096.     fprintf(stderr,"%s syntax OK\n", MPWFileName(origfilename));
  1097. #else
  1098.     fprintf(stderr,"%s syntax OK\n", origfilename);
  1099. #endif
  1100.     exit(0);
  1101.     }
  1102.  
  1103.     /* do it */
  1104.  
  1105.     (void) cmd_exec(main_root,G_SCALAR,-1);
  1106.  
  1107.     if (goto_targ)
  1108.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  1109.     exit(0);
  1110.     /* NOTREACHED */
  1111. }
  1112.  
  1113. void
  1114. magicalize(list)
  1115. register char *list;
  1116. {
  1117.     char sym[2];
  1118.  
  1119.     sym[1] = '\0';
  1120.     while (*sym = *list++)
  1121.     magicname(sym, Nullch, 0);
  1122. }
  1123.  
  1124. void
  1125. magicname(sym,name,namlen)
  1126. char *sym;
  1127. char *name;
  1128. int namlen;
  1129. {
  1130.     register STAB *stab;
  1131.  
  1132.     if (stab = stabent(sym,allstabs)) {
  1133.     stab_flags(stab) = SF_VMAGIC;
  1134.     str_magic(stab_val(stab), stab, 0, name, namlen);
  1135.     }
  1136. }
  1137.  
  1138. static void
  1139. incpush(p)
  1140. char *p;
  1141. {
  1142.     char *s;
  1143.  
  1144.     if (!p)
  1145.     return;
  1146.  
  1147.     /* Break at all separators */
  1148.     while (*p) {
  1149.     /* First, skip any consecutive separators */
  1150.     while ( *p == PERLLIB_SEP ) {
  1151.         /* Uncomment the next line for PATH semantics */
  1152.         /* (void)apush(stab_array(incstab), str_make(".", 1)); */
  1153.         p++;
  1154.     }
  1155. #ifdef macintosh
  1156.     if (gAppDir && !strncmp(p, "~:", 2)) {
  1157.         FSSpec    home;
  1158.         char *    ex;
  1159.         char      expanded[500];
  1160.         
  1161.         home.vRefNum = gAppVol;
  1162.         home.parID   = gAppDir;
  1163.         FSpUp(&home);
  1164.         
  1165.         strcpy(expanded, FSp2FullPath(&home));
  1166.         ex = expanded + strlen(expanded);
  1167.         p += 2;
  1168.         if (s = strrchr(p, PERLLIB_SEP)) {
  1169.             strncpy(ex, s, s-p);
  1170.             p = s + 1;
  1171.         } else {
  1172.             strcpy(ex, p);
  1173.         p = NULL;
  1174.         }
  1175.         (void)apush(stab_array(incstab), str_make(expanded, 0));
  1176.         if (!p)
  1177.             break;
  1178.     } else
  1179. #endif
  1180.     if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
  1181.         (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
  1182.         p = s + 1;
  1183.     } else {
  1184.         (void)apush(stab_array(incstab), str_make(p, 0));
  1185.         break;
  1186.     }
  1187.     }
  1188. }
  1189.  
  1190. void
  1191. savelines(array, str)
  1192. ARRAY *array;
  1193. STR *str;
  1194. {
  1195.     register char *s = str->str_ptr;
  1196.     register char *send = str->str_ptr + str->str_cur;
  1197.     register char *t;
  1198.     register int line = 1;
  1199.  
  1200.     while (s && s < send) {
  1201.     STR *tmpstr = Str_new(85,0);
  1202.  
  1203.     t = index(s, '\n');
  1204.     if (t)
  1205.         t++;
  1206.     else
  1207.         t = send;
  1208.  
  1209.     str_nset(tmpstr, s, t - s);
  1210.     astore(array, line++, tmpstr);
  1211.     s = t;
  1212.     }
  1213. }
  1214.  
  1215. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  1216. #ifdef macintosh
  1217.     static char * last_eval = Nullch;
  1218.     static long last_elen = 0;
  1219.     static CMD * last_root = Nullcmd;
  1220. #endif
  1221.  
  1222. int
  1223. do_eval(str,optype,stash,savecmd,gimme,arglast)
  1224. STR *str;
  1225. int optype;
  1226. HASH *stash;
  1227. int savecmd;
  1228. int gimme;
  1229. int *arglast;
  1230. {
  1231.     STR **st = stack->ary_array;
  1232.     int retval;
  1233.     CMD *myroot = Nullcmd;
  1234.     ARRAY *ar;
  1235.     int i;
  1236.     CMD * VOLATILE oldcurcmd = curcmd;
  1237.     VOLATILE int oldtmps_base = tmps_base;
  1238.     VOLATILE int oldsave = savestack->ary_fill;
  1239.     VOLATILE int oldperldb = perldb;
  1240.     SPAT * VOLATILE oldspat = curspat;
  1241.     SPAT * VOLATILE oldlspat = lastspat;
  1242.     VOLATILE int sp = arglast[0];
  1243.     char *specfilename;
  1244.     char *tmpfilename;
  1245.     int parsing = 1;
  1246. #ifndef macintosh
  1247.     static char * last_eval = Nullch;
  1248.     static long last_elen = 0;
  1249.     static CMD * last_root = Nullcmd;
  1250. #endif
  1251.  
  1252.     tmps_base = tmps_max;
  1253.     if (curstash != stash) {
  1254. #ifndef macintosh
  1255.     (void)savehptr(&curstash);
  1256. #else
  1257.     savehptr(&curstash);
  1258. #endif
  1259.     curstash = stash;
  1260.     }
  1261.     str_set(stab_val(stabent("@",TRUE)),"");
  1262.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1263.     perldb = FALSE;
  1264.     curcmd = &compiling;
  1265.     if (optype == O_EVAL) {        /* normal eval */
  1266.     curcmd->c_filestab = fstab("(eval)");
  1267.     curcmd->c_line = 1;
  1268.     str_sset(linestr,str);
  1269.     str_cat(linestr,";\n;\n");    /* be kind to them */
  1270.     if (perldb)
  1271.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1272.     }
  1273.     else {
  1274.     if (last_root && !in_eval) {
  1275.         Safefree(last_eval);
  1276.         last_eval = Nullch;
  1277.         cmd_free(last_root);
  1278.         last_root = Nullcmd;
  1279.     }
  1280.     specfilename = str_get(str);
  1281.     str_set(linestr,"");
  1282.     if (optype == O_REQUIRE && &str_undef !=
  1283.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1284.         curcmd = oldcurcmd;
  1285.         tmps_base = oldtmps_base;
  1286.         st[++sp] = &str_yes;
  1287.         perldb = oldperldb;
  1288.         return sp;
  1289.     }
  1290.     tmpfilename = savestr(specfilename);
  1291. #ifdef macintosh
  1292.     if ((strchr(tmpfilename, ':') != NULL) && *tmpfilename != ':') {
  1293. #else
  1294.     if (*tmpfilename == '/' || 
  1295.         (*tmpfilename == '.' &&
  1296.             (tmpfilename[1] == '/' ||
  1297.          (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
  1298.     {
  1299. #endif
  1300.         rsfp = fopen(tmpfilename,"r");
  1301.     }
  1302.     else {
  1303.         ar = stab_array(incstab);
  1304.         for (i = 0; i <= ar->ary_fill; i++) {
  1305. #ifdef macintosh
  1306.         char *macptr = str_get(afetch(ar,i,TRUE));
  1307.         int   colon1 = macptr[strlen(macptr)-1] == ':';
  1308.         int   colon2 = *specfilename == ':';
  1309.         
  1310.         if (colon1 && colon2)
  1311.             (void) sprintf(buf, "%s%s", macptr, specfilename+1);
  1312.         else if (colon1 || colon2 )
  1313.             (void) sprintf(buf, "%s%s", macptr, specfilename);
  1314.         else 
  1315.             (void) sprintf(buf, "%s:%s", macptr, specfilename);
  1316. #else
  1317.         (void)sprintf(buf, "%s/%s",
  1318.           str_get(afetch(ar,i,TRUE)), specfilename);
  1319. #endif
  1320.         rsfp = fopen(buf,"r");
  1321.         if (rsfp) {
  1322.             char *s = buf;
  1323.  
  1324. #ifndef macintosh
  1325.             if (*s == '.' && s[1] == '/')
  1326.             s += 2;
  1327. #endif
  1328.             Safefree(tmpfilename);
  1329.             tmpfilename = savestr(s);
  1330.             break;
  1331.         }
  1332.         }
  1333.     }
  1334.     curcmd->c_filestab = fstab(tmpfilename);
  1335.     Safefree(tmpfilename);
  1336.     tmpfilename = Nullch;
  1337.     if (!rsfp) {
  1338.         curcmd = oldcurcmd;
  1339.         tmps_base = oldtmps_base;
  1340.         if (optype == O_REQUIRE) {
  1341.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1342.         if (instr(tokenbuf,".h "))
  1343.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1344.         if (instr(tokenbuf,".ph "))
  1345.             strcat(tokenbuf," (did you run h2ph?)");
  1346.         fatal("%s",tokenbuf);
  1347.         }
  1348.         if (gimme != G_ARRAY)
  1349.         st[++sp] = &str_undef;
  1350.         perldb = oldperldb;
  1351.         return sp;
  1352.     }
  1353.     curcmd->c_line = 0;
  1354.     }
  1355.     in_eval++;
  1356.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1357.     bufend = bufptr + linestr->str_cur;
  1358.     if (++loop_ptr >= loop_max) {
  1359.     loop_max += 128;
  1360.     Renew(loop_stack, loop_max, struct loop);
  1361.     }
  1362.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1363.     loop_stack[loop_ptr].loop_sp = sp;
  1364. #ifdef DEBUGGING
  1365.     if (debug & 4) {
  1366.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1367.     }
  1368. #endif
  1369.     eval_root = Nullcmd;
  1370.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1371.     retval = 1;
  1372.     }
  1373.     else {
  1374.     error_count = 0;
  1375.     if (rsfp) {
  1376.         retval = yyparse();
  1377.         retval |= error_count;
  1378.     }
  1379.     else if (last_root && last_elen == bufend - bufptr
  1380.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1381.         retval = 0;
  1382.         eval_root = last_root;    /* no point in reparsing */
  1383.     }
  1384.     else if (in_eval == 1 && !savecmd) {
  1385.         if (last_root) {
  1386.         Safefree(last_eval);
  1387.         last_eval = Nullch;
  1388.         cmd_free(last_root);
  1389.         }
  1390.         last_root = Nullcmd;
  1391.         last_elen = bufend - bufptr;
  1392.         last_eval = nsavestr(bufptr, last_elen);
  1393.         retval = yyparse();
  1394.         retval |= error_count;
  1395.         if (!retval)
  1396.         last_root = eval_root;
  1397.         if (!last_root) {
  1398.         Safefree(last_eval);
  1399.         last_eval = Nullch;
  1400.         }
  1401.     }
  1402.     else
  1403.         retval = yyparse();
  1404.     }
  1405.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1406.  
  1407.     if (retval || error_count) {
  1408.     st = stack->ary_array;
  1409.     sp = arglast[0];
  1410.     if (gimme != G_ARRAY)
  1411.         st[++sp] = &str_undef;
  1412.     if (parsing) {
  1413. #ifndef MANGLEDPARSE
  1414. #ifdef DEBUGGING
  1415. #ifdef macintosh
  1416.         if (debug & 128)
  1417.         fprintf(perldbg,"Freeing eval_root %lx\n",(long)eval_root);
  1418. #else
  1419.         if (debug & 128)
  1420.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1421. #endif
  1422. #endif
  1423.         cmd_free(eval_root);
  1424. #endif
  1425.         /*SUPPRESS 29*/ /*SUPPRESS 30*/
  1426.         if ((CMD*)eval_root == last_root)
  1427.         last_root = Nullcmd;
  1428.         eval_root = myroot = Nullcmd;
  1429.     }
  1430.     if (rsfp) {
  1431.         fclose(rsfp);
  1432.         rsfp = 0;
  1433.     }
  1434.     }
  1435.     else {
  1436.     parsing = 0;
  1437.     sp = cmd_exec(eval_root,gimme,sp);
  1438.     st = stack->ary_array;
  1439.     for (i = arglast[0] + 1; i <= sp; i++)
  1440.         st[i] = str_mortal(st[i]);
  1441.                 /* if we don't save result, free zaps it */
  1442.     if (savecmd)
  1443.         eval_root = myroot;
  1444.     else if (in_eval != 1 && myroot != last_root)
  1445.         cmd_free(myroot);
  1446.         if (eval_root == myroot)
  1447.         eval_root = Nullcmd;
  1448.     }
  1449.  
  1450.     perldb = oldperldb;
  1451.     in_eval--;
  1452. #ifdef DEBUGGING
  1453.     if (debug & 4) {
  1454.     char *tmps = loop_stack[loop_ptr].loop_label;
  1455.     deb("(Popping label #%d %s)\n",loop_ptr,
  1456.         tmps ? tmps : "" );
  1457.     }
  1458. #endif
  1459.     loop_ptr--;
  1460.     tmps_base = oldtmps_base;
  1461.     curspat = oldspat;
  1462.     lastspat = oldlspat;
  1463.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1464.     restorelist(oldsave);
  1465.  
  1466.     if (optype != O_EVAL) {
  1467.     if (retval) {
  1468.         if (optype == O_REQUIRE)
  1469.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1470.     }
  1471.     else {
  1472.         curcmd = oldcurcmd;
  1473.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1474.         (void)hstore(stab_hash(incstab), specfilename,
  1475.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1476.               0 );
  1477.         }
  1478.         else if (optype == O_REQUIRE)
  1479.         fatal("%s did not return a true value", specfilename);
  1480.     }
  1481.     }
  1482.     curcmd = oldcurcmd;
  1483.     return sp;
  1484. }
  1485.  
  1486. int
  1487. do_try(cmd,gimme,arglast)
  1488. CMD *cmd;
  1489. int gimme;
  1490. int *arglast;
  1491. {
  1492.     STR **st = stack->ary_array;
  1493.  
  1494.     CMD * VOLATILE oldcurcmd = curcmd;
  1495.     VOLATILE int oldtmps_base = tmps_base;
  1496.     VOLATILE int oldsave = savestack->ary_fill;
  1497.     SPAT * VOLATILE oldspat = curspat;
  1498.     SPAT * VOLATILE oldlspat = lastspat;
  1499.     VOLATILE int sp = arglast[0];
  1500.  
  1501.     tmps_base = tmps_max;
  1502.     str_set(stab_val(stabent("@",TRUE)),"");
  1503.     in_eval++;
  1504.     if (++loop_ptr >= loop_max) {
  1505.     loop_max += 128;
  1506.     Renew(loop_stack, loop_max, struct loop);
  1507.     }
  1508.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1509.     loop_stack[loop_ptr].loop_sp = sp;
  1510. #ifdef DEBUGGING
  1511.     if (debug & 4) {
  1512.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1513.     }
  1514. #endif
  1515.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1516.     st = stack->ary_array;
  1517.     sp = arglast[0];
  1518.     if (gimme != G_ARRAY)
  1519.         st[++sp] = &str_undef;
  1520.     }
  1521.     else {
  1522.     sp = cmd_exec(cmd,gimme,sp);
  1523.     st = stack->ary_array;
  1524. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1525.         st[i] = str_mortal(st[i]);  not needed, I think */
  1526.                 /* if we don't save result, free zaps it */
  1527.     }
  1528.  
  1529.     in_eval--;
  1530. #ifdef DEBUGGING
  1531.     if (debug & 4) {
  1532.     char *tmps = loop_stack[loop_ptr].loop_label;
  1533.     deb("(Popping label #%d %s)\n",loop_ptr,
  1534.         tmps ? tmps : "" );
  1535.     }
  1536. #endif
  1537.     loop_ptr--;
  1538.     tmps_base = oldtmps_base;
  1539.     curspat = oldspat;
  1540.     lastspat = oldlspat;
  1541.     curcmd = oldcurcmd;
  1542.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1543.     restorelist(oldsave);
  1544.  
  1545.     return sp;
  1546. }
  1547.  
  1548. /* This routine handles any switches that can be given during run */
  1549.  
  1550. static char *
  1551. moreswitches(s)
  1552. char *s;
  1553. {
  1554.     int numlen;
  1555.  
  1556.     switch (*s) {
  1557.     case '0':
  1558.     nrschar = scanoct(s, 4, &numlen);
  1559.     nrs = nsavestr("\n",1);
  1560.     *nrs = nrschar;
  1561.     if (nrschar > 0377) {
  1562.         nrslen = 0;
  1563.         nrs = "";
  1564.     }
  1565.     else if (!nrschar && numlen >= 2) {
  1566.         nrslen = 2;
  1567.         nrs = "\n\n";
  1568.         nrschar = '\n';
  1569.     }
  1570.     return s + numlen;
  1571.     case 'a':
  1572.     minus_a = TRUE;
  1573.     s++;
  1574.     return s;
  1575.     case 'c':
  1576.     minus_c = TRUE;
  1577.     s++;
  1578.     return s;
  1579.     case 'd':
  1580. #ifdef TAINT
  1581.     if (euid != uid || egid != gid)
  1582.         fatal("No -d allowed in setuid scripts");
  1583. #endif
  1584.     perldb = TRUE;
  1585.     s++;
  1586.     return s;
  1587.     case 'D':
  1588. #ifdef DEBUGGING
  1589. #ifdef TAINT
  1590.     if (euid != uid || egid != gid)
  1591.         fatal("No -D allowed in setuid scripts");
  1592. #endif
  1593.     debug = atoi(s+1) | 32768;
  1594. #else
  1595.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1596. #endif
  1597.     /*SUPPRESS 530*/
  1598.     for (s++; isDIGIT(*s); s++) ;
  1599.     return s;
  1600.     case 'i':
  1601.     inplace = savestr(s+1);
  1602.     /*SUPPRESS 530*/
  1603.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1604.     *s = '\0';
  1605.     break;
  1606.     case 'I':
  1607. #ifdef TAINT
  1608.     if (euid != uid || egid != gid)
  1609.         fatal("No -I allowed in setuid scripts");
  1610. #endif
  1611.     if (*++s) {
  1612.         (void)apush(stab_array(incstab),str_make(s,0));
  1613.     }
  1614.     else
  1615.         fatal("No space allowed after -I");
  1616.     break;
  1617.     case 'l':
  1618.     minus_l = TRUE;
  1619.     s++;
  1620.     if (isDIGIT(*s)) {
  1621.         ors = savestr("\n");
  1622.         orslen = 1;
  1623.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1624.         s += numlen;
  1625.     }
  1626.     else {
  1627.         ors = nsavestr(nrs,nrslen);
  1628.         orslen = nrslen;
  1629.     }
  1630.     return s;
  1631.     case 'n':
  1632.     minus_n = TRUE;
  1633.     s++;
  1634.     return s;
  1635.     case 'p':
  1636.     minus_p = TRUE;
  1637.     s++;
  1638.     return s;
  1639.     case 'u':
  1640.     do_undump = TRUE;
  1641.     s++;
  1642.     return s;
  1643.     case 'U':
  1644.     unsafe = TRUE;
  1645.     s++;
  1646.     return s;
  1647.     case 'v':
  1648.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1649.     fputs(rcsid,stdout);
  1650.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1651. #ifdef macintosh
  1652.     fputs("MPW port Copyright (c) 1991-95 Matthias Neeracher & Tim Endres\n",
  1653.     stdout);
  1654. #endif    
  1655. #ifdef MSDOS
  1656.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1657.     stdout);
  1658. #ifdef OS2
  1659.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1660.         stdout);
  1661. #endif
  1662. #endif
  1663. #ifdef atarist
  1664.         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
  1665. #endif
  1666.     fputs("\n\
  1667. Perl may be copied only under the terms of the Perl Artistic License \n\
  1668. which may be found in the Perl 4.0 source kit.\n",stdout);
  1669. #ifdef MSDOS
  1670.         usage(origargv[0]);
  1671. #endif
  1672.     exit(0);
  1673.     case 'w':
  1674.     dowarn = TRUE;
  1675.     s++;
  1676.     return s;
  1677.     case ' ':
  1678.     case '\n':
  1679.     case '\t':
  1680.     break;
  1681.     default:
  1682. #ifdef macintosh
  1683.         if (doextract)
  1684. #endif
  1685.         fatal("Switch meaningless after -x: -%s",s);
  1686.     }
  1687.     return Nullch;
  1688. }
  1689.  
  1690. /* compliments of Tom Christiansen */
  1691.  
  1692. /* unexec() can be found in the Gnu emacs distribution */
  1693.  
  1694. void
  1695. my_unexec()
  1696. {
  1697. #ifdef UNEXEC
  1698.     int    status;
  1699.     extern int etext;
  1700.     static char dumpname[BUFSIZ];
  1701.     static char perlpath[256];
  1702.  
  1703.     sprintf (dumpname, "%s.perldump", origfilename);
  1704.     sprintf (perlpath, "%s/perl", BIN);
  1705.  
  1706.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1707.     if (status)
  1708.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1709.     exit(status);
  1710. #else
  1711. #ifdef DOSISH
  1712.     abort();    /* nothing else to do */
  1713. #else /* ! MSDOS */
  1714. #   ifndef SIGABRT
  1715. #    define SIGABRT SIGILL
  1716. #   endif
  1717. #   ifndef SIGILL
  1718. #    define SIGILL 6        /* blech */
  1719. #   endif
  1720.     kill(getpid(),SIGABRT);    /* for use with undump */
  1721. #endif /* ! MSDOS */
  1722. #endif
  1723. }
  1724.  
  1725. #ifdef macintosh
  1726. void reinit_perl()
  1727. {
  1728.     cddir     = NULL;
  1729.     nrs       = "\n";
  1730.     nrschar     = '\n';
  1731.     nrslen    = 1;
  1732.     last_eval   = Nullch;
  1733.     last_elen   = 0;
  1734.     last_root   = Nullcmd;
  1735. }
  1736. #endif